# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Lesser General Public License as
# published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this program.  If not, see
# <http://www.gnu.org/licenses/>.

package bamp::ApiParser;

use warnings;
use strict;
use Text::ParseWords;
use Data::Dumper;

# Private methods forward declarations
sub __parse_all($);
sub __parse_block($$$$);
sub __parse_type($$$$);
sub __parse_class($$$$);
sub __parse_attrib($$$$$);
sub __parse_method($$$$);
sub __get_errors($);
sub __report_error($$$);
sub __lookup_type($$);
sub __add_parent($$$);


sub new($$)
{
    my ($perlclass, $file, $class) = @_;
    
    # Become an object
    my $self = { class => $class };
    bless $self;

    # Read the file. Add line number tags to help make clearer parsing
    # error messages.
    my $contents = "";
    my $lineno   = 1;
    open(my $fh, "<", $file) or die "cannot open $file: $!";
    $contents .= "[".$lineno++."]".$_ for <$fh>;
    close($fh);

    # Parse the file
    ${$self}{file} = $file;
    $self->__parse_all($contents);

    return $self;
}


sub methods()
{
    my $self = shift;
    my $class = ${$self}{class};
    return @{${$self}{classes}{$class}{methods}};
}


sub class_methods()
{
    my ($self, $class) = @_;
    return () unless defined ${$self}{classes}{$class}{methods};
    return @{${$self}{classes}{$class}{methods}};
}


sub all_methods()
{
    my $self = shift;
    my $class = ${$self}{class};
    my @methods = @{${$self}{classes}{$class}{methods}};
    for my $parent ($self->parents())
    {
        push (@methods, $self->class_methods($parent));
    }
    return @methods;
}

sub parents()
{
    my $self = shift;
    my $class = ${$self}{class};
    return () unless defined ${$self}{classes}{$class}{parents};
    return @{${$self}{classes}{$class}{parents}};
}


sub first_out($)
{
    my ($self, $method) = @_;

    for my $arg (@{${$method}{args}})
    {
        my $dir = ${$arg}[1];
        return $arg if $dir eq "out";
    }

    return undef;
}


sub all_out($)
{
    my ($self, $method) = @_;
    my @args = ();

    for my $arg (@{${$method}{args}})
    {
        my $dir = ${$arg}[1];
        next unless defined $dir;
        next unless $dir eq "out" || $dir eq "io";
        push @args, $arg;
    }

    return @args;
}

sub includes($$)
{
    my ($self, $lang, @other) = @_;
    my $class = ${$self}{class};
    my @list = ();

    # Include user includes
    push @list, @other;

    # Add the includes required by parents
    for my $parent (@{${$self}{classes}{$class}{parents}})
    {
        my $incl = ${${$self}{types}{$parent}{langs}{$lang}}[1];
        push @list, $incl if defined $incl;
    }

    # Add the includes required for the types used by the class API
    for my $meth (@{${$self}{classes}{$class}{methods}})
    {
        for my $arg (@{${$meth}{args}})
        {
            my $type = ${${$arg}[2]}{$lang};
            my $incl = ${$self}{includes}{$lang}{$type} if defined $type;
            push @list, $incl if defined $incl;
        }
    }

    # Remove duplicate (see: perldoc -q duplicate)
    my %seen = ();
    my @unique = grep { ! $seen{ $_ }++ } @list;

    return @unique;
}


sub __get_errors($)
{
    my $contents = shift;

    # Split contents at line tags
    my @errors = split(/\[(\d+)\]/, $contents);
    shift @errors;
    pop @errors unless ($#errors % 2);

    # Create a line => contents mapping
    my %errors = @errors;
    return %errors;
}


sub __report_error($$$)
{
    my ($self, $line, $error) = @_;
    if (defined $line)
    {
        print STDERR ${$self}{file}.":".$line.": error: ".$error."\n";
        ${$self}{errors}{$line} = $error;
    }
    else
    {
        print STDERR ${$self}{file}.": error: ".$error."\n";
        ${$self}{errors}{0} = $error;
    }
}


sub __parse_all($)
{
    my ($self, $contents) = @_;

    my $spc = qr/\s*?(?:\[\d+\])?\s*?/s;

    # Remove comments and empty lines
    $contents =~ s/^$spc(#.*)?\r?\n//mg;

    # Find top-level blocks: type and class definitions. Each time
    # such a block is found, remove it from the input and parse it
    # separately.
    my $re = qr/$spc(type|class)$spc([\w\|\:]+)$spc(?:\(([\w :]*)\))?$spc\{(.*?)\}/s;
    $contents =~ s/$re/$self->__parse_block($1,$2,$3,$4)/ge;

    # Report remaining lines as parsing errors
    my %errors = __get_errors($contents);
    for my $line (sort {$a <=> $b} keys %errors)
    {
        $self->__report_error($line, "expected class or type definition");
    }
}


sub __parse_block($$$$)
{
    my ($self, $btype, $bname, $quals, $block) = @_;

    my $spc = qr/\s*?(?:\[\d+\])?\s*?/s;
    my $error = "syntax error";

    # Find out the line number
    my $line;
    $line = $1 if $block =~ m/\[(\d+)\]/;

    # Call the appropriate block parser for that block type. The
    # "quals" part is a list of type qualifiers or a list of class
    # parents, depending on the context.
    if ($btype eq "type")
    {
        my $re = qr/$spc(\S+)$spc\((.*?)\)(.*?);/s;
        $block =~ s/$re/$self->__parse_type($bname, $1, $2, $3)/ge;
        $error = "expected type mapping";
    }
    elsif ($btype eq "class")
    {
        my $re = qr/\s*(?:\[(\d+)\])?$spc(attrib|method)(.*?);/s;
        $block =~ s/$re/$self->__parse_class($bname, $2, $3, $1)/ge;
        $error = "expected attribute or method declaration";
        if (defined $quals)
        {
            $self->__add_parent($bname, $_, $line) for split(' ', $quals);
        }
    }

    # Report remaining lines as parsing errors
    my %errors = __get_errors($block);
    for $line (sort {$a <=> $b} keys %errors)
    {
        $self->__report_error($line, $error);
    }

    return "";
}

sub __parse_type($$$$)
{
    my ($self, $bname, $lang, $args, $quals) = @_;

    # Get internal types, corresponding external types and what must
    # be included when they are used.
    my ($etypes, $incl) = quotewords('\s+', 0, $args);
    my @itypes = split /\s*\|\s*/, $bname;
    my @etypes = split /\s*\|\s*/, $etypes;
    my @quals  = defined $quals ? split ' ', $quals : ();

    $incl = undef unless defined $incl && length($incl) > 0;

    # Insert the internal => external type mapping into the API
    my %typemap;
    @typemap{@itypes} = @etypes;
    for (@itypes)
    {
        ${$self}{types}{$_}{langs}{$lang} = [$typemap{$_}, $incl];
        ${$self}{includes}{$lang}{$typemap{$_}} = $incl;
        for my $q (@quals)
        {
            ${$self}{types}{$_}{quals}{$lang}{$q} = 1;
        }
    }

    return "";
}

sub __parse_class($$$$)
{
    my ($self, $class, $eltype, $element, $line) = @_;

    my $spc = qr/\s*?(?:\[\d+\])?\s*?/s;
    my $error = "syntax error";

    # Find out the line number
    $line = $1 if $element =~ m/\[(\d+)\]/;

    # Call the appropriate parser depending on the element found
    if ($eltype eq "attrib")
    {
        $error = "invalid attribute declaration";
        my $re = qr/^$spc(\w+)$spc\:$spc(ro|wo|rw)$spc([\w:]+)$spc$/s;
        $element =~ s/$re/$self->__parse_attrib($class,$1,$2,$3,$line)/ge
            or $self->__report_error($line, $error);
    }
    elsif ($eltype eq "method")
    {
        $error = "invalid method declaration";
        my $re = qr/^$spc(\w+)$spc(?:\((.*?)\))?$spc((?:\w|$spc)+)$/s;
        $element =~ s/$re/$self->__parse_method($class,$1,$2,$3)/sge
            or $self->__report_error($line, $error);
    }

    # Report remaining lines as parsing errors
    my %errors = __get_errors($element);
    for $line (sort {$a <=> $b} keys %errors)
    {
        $self->__report_error($line, $error);
    }

    return "";
}

sub __parse_attrib($$$$$)
{
    my ($self, $class, $name, $access, $typename, $line) = @_;

    # Create a getter and/or a setter for the attribute
    if ($access eq "ro" || $access eq "rw")
    {
        my ($type, $tquals) = $self->__lookup_type($typename, $line);
        push @{${$self}{classes}{$class}{methods}}, {
            name  => "get_$name",
            args  => [[$name, "out", $type, '', $tquals]],
            const => 1
        };
    }
    if ($access eq "wo" || $access eq "rw")
    {
        my ($type, $tquals) = $self->__lookup_type($typename, $line);
        push @{${$self}{classes}{$class}{methods}}, {
            name  => "set_$name",
            args  => [[$name, "in", $type, '', $tquals]]
        };
    }

    return "";
}

sub __parse_method($$$$)
{
    my ($self, $class, $name, $args, $qual) = @_;

    my $spc = qr/\s*?(?:\[\d+\])?\s*?/s;
    my %method;
    
    # Arguments and qualifiers are optional
    $args = "" unless defined $args;
    $qual = "" unless defined $qual;

    # Set method name
    $method{name} = $name;
    $method{args} = [];

    # Add arguments. Arguments are declared using internal
    # typenames. These types must have been declared previously so
    # that we can look them up.
    my $lineno;
    for (quotewords (',', 0, $args))
    {
        $lineno = $1 if m/\[(\d+)\]/;
        if (m/^$spc(\w+)$spc\:$spc(in|out|io)$spc([\w\:]+)(.*?)$spc/)
        {
            my ($type, $tquals) = $self->__lookup_type($3, $lineno);
            push @{$method{args}}, [$1, $2, $type, $4, $tquals];
        }
        else
        {
            $self->__report_error($lineno, "expected argument declaration");
        }
    }

    # Add method qualifiers
    $method{$_} = 1 for (split (' ', $qual));

    # Add the method
    push @{${$self}{classes}{$class}{methods}}, \%method;

    return "";
}


sub __lookup_type($$)
{
    my ($self, $typename, $line) = @_;

    # Make sure the type has been declared
    unless (exists ${$self}{types}{$typename})
    {
        $self->__report_error
            ($line, "$typename: type was not previously declared");
        return undef;
    }

    # Copy the type mapping
    my %type;
    for my $lang (keys %{${$self}{types}{$typename}{langs}})
    {
        $type{$lang} = ${${$self}{types}{$typename}{langs}{$lang}}[0];
    }

    # Copy the qualifiers
    my %quals;

    for my $lang (keys %{${$self}{types}{$typename}{quals}})
    {
        for my $qual (keys %{${$self}{types}{$typename}{quals}{$lang}})
        {
            $quals{$lang}{$qual} =
                ${$self}{types}{$typename}{quals}{$lang}{$qual};
        }
    }

    return (\%type, \%quals);
}

sub __add_parent($$$)
{
    my ($self, $class, $parent, $line) = @_;

    # Make sure the parent does exist
    unless (exists(${$self}{classes}{$parent}))
    {
        $self->__report_error
            ($line, "$parent: class has not been previously declared");
    }

    # Add the the parent to the class' parent list
    @{${$self}{classes}{$class}{parents}} = ()
        unless exists ${$self}{classes}{$class}{parents};
    push @{${$self}{classes}{$class}{parents}}, $parent;
}

1;
